home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / ppfile.scm < prev    next >
Text File  |  1999-04-19  |  2KB  |  71 lines
  1. ;;;; "ppfile.scm".  Pretty print a Scheme file.
  2. ;Copyright (C) 1993, 1994 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'pretty-print)
  21.  
  22. (define (pprint-filter-file inport filter . optarg)
  23.   ((lambda (fun)
  24.      (if (input-port? inport)
  25.      (fun inport)
  26.      (call-with-input-file inport fun)))
  27.    (lambda (port)
  28.      ((lambda (fun)
  29.     (let ((outport
  30.            (if (null? optarg) (current-output-port) (car optarg))))
  31.       (if (output-port? outport)
  32.           (fun outport)
  33.           (call-with-output-file outport fun))))
  34.       (lambda (export)
  35.     (let ((old-load-pathname *load-pathname*))
  36.       (set! *load-pathname* inport)
  37.       (letrec ((lp (lambda (c)
  38.              (cond ((eof-object? c))
  39.                    ((char-whitespace? c)
  40.                 (display (read-char port) export)
  41.                 (lp (peek-char port)))
  42.                    ((char=? #\; c)
  43.                 (cmt c))
  44.                    (else (sx)))))
  45.            (cmt (lambda (c)
  46.               (cond ((eof-object? c))
  47.                 ((char=? #\newline c)
  48.                  (display (read-char port) export)
  49.                  (lp (peek-char port)))
  50.                 (else
  51.                  (display (read-char port) export)
  52.                  (cmt (peek-char port))))))
  53.            (sx (lambda ()
  54.              (let ((o (read port)))
  55.                (cond ((eof-object? o))
  56.                  (else
  57.                   (pretty-print (filter o) export)
  58.                   ;; pretty-print seems to have extra newline
  59.                   (let ((c (peek-char port)))
  60.                     (cond ((eqv? #\newline c)
  61.                        (read-char port)
  62.                        (set! c (peek-char port))))
  63.                     (lp c))))))))
  64.         (lp (peek-char port)))
  65.       (set! *load-pathname* old-load-pathname)))))))
  66.  
  67. (define (pprint-file ifile . optarg)
  68.   (pprint-filter-file ifile
  69.               (lambda (x) x)
  70.               (if (null? optarg) (current-output-port) (car optarg))))
  71.